home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / prog.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  2KB  |  74 lines
  1. ;
  2. ;; EuLisp prog macro
  3. ;
  4.  
  5. (defmodule prog (standard0) ()
  6.  
  7.   ;
  8.   ;; Do the meat of the problem in tagbody...
  9.   ;;
  10.   ;;  Go for serious continuation abuse here in order to limit stack
  11.   ;;  use in a compiler that can't deal with tail in general.
  12.   ;
  13.  
  14.   (defconstant *tagbody-dispatcher-name* (gensym))
  15.  
  16.   (defun tagbody-until-label (forms)
  17.     (cond ((null forms) nil)
  18.       ((symbolp (car forms)) (tagbody-until-label (cdr forms)))
  19.       (t (cons (car forms) (tagbody-until-label (cdr forms))))))
  20.  
  21.   (defun tagbody-forms-before-a-label (forms)
  22.     (cond ((null forms) nil)
  23.       ((symbolp (car forms)) nil)
  24.       (t (cons (car forms) (tagbody-forms-before-a-label (cdr forms))))))
  25.     
  26.   (defun tagbody-label-forms (forms)
  27.     (cond ((null forms) nil)
  28.       ((symbolp (car forms))
  29.        (cons
  30.         (cons (car forms) (cons () (tagbody-until-label (cdr forms))))
  31.         (tagbody-label-forms (cdr forms))))
  32.       (t (tagbody-label-forms (cdr forms)))))
  33.  
  34.   (defun tagbody-first-label (forms)
  35.     (cond ((null forms) nil)
  36.       ((symbolp (car forms)) (car forms))
  37.       (t (tagbody-first-label (cdr forms)))))
  38.  
  39.   (defmacro ctagbody forms
  40.     (let ((tag-label-forms (tagbody-label-forms forms)))
  41.       (if (null tag-label-forms) ; No labels at all
  42.     `(let/cc return ,@forms)
  43.     `(let/cc return 
  44.        (let ((,*tagbody-dispatcher-name* ()))
  45.          (labels 
  46.            ,tag-label-forms
  47.            (let/cc dropped-out
  48.          (labels
  49.                ((dispatcher (fn)
  50.               (dispatcher 
  51.                 (let/cc called
  52.               (setq ,*tagbody-dispatcher-name* called)
  53.               (dropped-out (fn))))))
  54.             ; these must see the tags
  55.            (dispatcher 
  56.              (let/cc panic
  57.                (setq ,*tagbody-dispatcher-name* panic)
  58.                ,@(tagbody-forms-before-a-label forms)
  59.                        ,(tagbody-first-label forms)))))))))))
  60.  
  61.   (defmacro cgo (name)
  62.     `(go ,name))
  63.        
  64.   (defmacro cprog (vars . forms)
  65.     `(let/cc return
  66.        ((lambda ,vars (tagbody ,@forms)) ,@(mapcar (lambda (a) ()) vars))))
  67.  
  68.   (export ctagbody cgo cprog)
  69.  
  70. )
  71.  
  72.  
  73.       
  74.